home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Icon 8.1 / msm-2 / iconc.sit / mktoktab.icn < prev    next >
Encoding:
Text File  |  1992-09-19  |  15.2 KB  |  529 lines  |  [TEXT/MPS ]
  1. # Build the files:
  2. #    toktab.c - token tables and operator recognizer
  3. #    icon_g.h - %token declarations for YACC
  4. # from token description file "tokens.txt" and operator description
  5. # file "op.txt".
  6.  
  7. global token, tokval, bflag, eflag, head, oper, tail, count
  8. global restable, flagtable, op_lst, asgn_loc, semicol_loc, plus_loc, minus_loc
  9. global white_sp, unary_set
  10. global tokfile, opfile, toktab, tok_dot_h
  11.  
  12. record op_sym(op, aug, tokval, unary, binary)
  13. record association(op, n)
  14. record trie(by_1st_c, dflt)
  15.  
  16. procedure tokpat()
  17.    if tab(many(white_sp)) & (token := tab(upto(white_sp))) &
  18.       tab(many(white_sp)) & (tokval := (tab(upto(white_sp) | 0)))
  19.    then return (tab(upto('b')) & (bflag := move(1))) | (bflag := "") &
  20.       ((tab(upto('e')) & (eflag := move(1))) | (eflag := "")) & pos(0)
  21. end
  22.  
  23. procedure main()
  24.    local line, letter, lastletter
  25.    local s, op, aug, tok, unary, binary, tok_chars, sym, op_trie
  26.    local prognm, tokfnm, opfnm, toktbnm, dothnm, op_linenum
  27.  
  28.    white_sp := ' \t'
  29.  
  30.    prognm := "mktoktab"
  31.    tokfnm := "tokens.txt"
  32.    opfnm := "op.txt"
  33.    toktbnm := "toktab.c"
  34.    dothnm := "icon_g.h"
  35.  
  36.    restable := table()
  37.    flagtable := table("")
  38.    flagtable[""] := "0"
  39.    flagtable["b"] := "Beginner"
  40.    flagtable["e"] := "Ender"
  41.    flagtable["be"] := "Beginner+Ender"
  42.    count := 0
  43.    lastletter := ""
  44.  
  45.    tokfile := open(tokfnm) | stop("unable to open \"", tokfnm, "\"")
  46.    opfile := open(opfnm) | stop("unable to open \"", opfnm, "\"")
  47.    toktab := open(toktbnm,"w") | stop("unable to create \"", toktbnm, "\"")
  48.    tok_dot_h := open(dothnm,"w") | stop("unable to create \"", dothnm, "\"")
  49.  
  50. # Output header for token table
  51.    write(toktab,"/*")
  52.    write(toktab," * NOTE, this file is generated automatically by ", prognm)
  53.    write(toktab," *  from ", tokfnm, " and ", opfnm, ".")
  54.    write(toktab," */")
  55.    write(toktab,"#include \"../h/gsupport.h\"")
  56.    write(toktab,"#include \"trans.h\"")
  57.    write(toktab,"#include \"tree.h\"")
  58.    write(toktab,"#include \"tcode.h\"")
  59.    write(toktab,"#include \"tsym.h\"")
  60.    write(toktab,"#include \"tlex.h\"")
  61.    write(toktab,"#include \"token.h\"")
  62.    write(toktab,"#include \"tproto.h\"")
  63.    write(toktab)
  64.    write(toktab,"/*")
  65.    write(toktab," * Token table - contains an entry for each token type")
  66.    write(toktab," * with printable name of token, token type, and flags")
  67.    write(toktab," * for semicolon insertion.")
  68.    write(toktab," */")
  69.    write(toktab)
  70.    write(toktab,"struct toktab toktab[] = {")
  71.    write(toktab,"/*  token\t\ttoken type\tflags */")
  72.    write(toktab)
  73.    write(toktab,"   /* primitives */")
  74.  
  75. # output header for token include file
  76.    write(tok_dot_h,"/*")
  77.    write(tok_dot_h," * NOTE, these %token declarations are generated")
  78.    write(tok_dot_h," *  automatically by ", prognm, " from ", tokfnm, " and ")
  79.    write(tok_dot_h," *  ", opfnm, ".")
  80.    write(tok_dot_h," */")
  81.    write(tok_dot_h)
  82.    write(tok_dot_h, "/* primitive tokens */")
  83.    write(tok_dot_h)
  84.  
  85.  
  86. # Skip the first few (non-informative) lines of "tokens.txt"
  87.  
  88.    garbage()
  89.  
  90. # Read primitive tokens
  91.  
  92.    repeat {
  93.       write(toktab,makeline(token,tokval,bflag || eflag,count))
  94.       wrt_tok_def(tokval)
  95.       count +:= 1
  96.       line := read(tokfile) | stop("premature end-of-file")
  97.       line ? tokpat() | break
  98.          }
  99.  
  100. # Skip some more garbage lines
  101.  
  102.    garbage()
  103.  
  104. # Output some more comments
  105.  
  106.    write(toktab)
  107.    write(toktab,"   /* reserved words */")
  108.    write(tok_dot_h)
  109.    write(tok_dot_h, "/* reserved words */")
  110.    write(tok_dot_h)
  111.  
  112. # Read in reserved words, output them,
  113. # and build table of first letters.
  114.  
  115.    repeat {
  116.       write(toktab,makeline(token,tokval,bflag || eflag,count))
  117.       wrt_tok_def(tokval, token)
  118.       letter := token[1]
  119.       if letter ~== lastletter then {
  120.          lastletter := letter
  121.          restable[letter] := count
  122.         }
  123.    count +:= 1
  124.    line := read(tokfile) | stop("premature end-of-file")
  125.    if line ? tokpat() then next else break
  126.    }
  127.  
  128. # output end of token table and reserveed word first-letter index.
  129.  
  130.    write(toktab,makeline("end-of-file","0","",""))
  131.    write(toktab,"   };")
  132.    write(toktab)
  133.    write(toktab,"/*")
  134.    write(toktab," * restab[c] points to the first reserved word in toktab which")
  135.    write(toktab," * begins with the letter c.")
  136.    write(toktab," */")
  137.    write(toktab)
  138.    write(toktab,"struct toktab *restab[] = {")
  139.    write(toktab,"#if !EBCDIC")
  140.    write(toktab,makeres("abcd", 16r61))
  141.    write(toktab,makeres("efgh"))
  142.    write(toktab,makeres("ijkl"))
  143.    write(toktab,makeres("mnop"))
  144.    write(toktab,makeres("qrst"))
  145.    write(toktab,makeres("uvwx"))
  146.    write(toktab,makeres("yz"))
  147.    write(toktab,"#else                    /* EBCDIC */")
  148.    write(toktab,makeres("abcd", 16r81))
  149.    write(toktab,makeres("efgh"))
  150.    write(toktab,makeres("i..."))
  151.    write(toktab,makeres("...."))
  152.    write(toktab,makeres("jklm"))
  153.    write(toktab,makeres("nopq"))
  154.    write(toktab,makeres("r..."))
  155.    write(toktab,makeres("...."))
  156.    write(toktab,makeres(".stu"))
  157.    write(toktab,makeres("vwxy"))
  158.    write(toktab,makeres("z"))
  159.    write(toktab,"#endif                    /* EBCDIC */")
  160.    write(toktab,"   };")
  161.  
  162. # Another comment
  163.  
  164.    write(toktab)
  165.    write(toktab,"/*")
  166.    write(toktab," * The operator table acts to extend the token table, it")
  167.    write(toktab," *  indicates what implementations are expected from rtt,")
  168.    write(toktab," *  and it has pointers for the implementation information.")
  169.    write(toktab," */")
  170.    write(toktab)
  171.    write(toktab, "struct optab optab[] = {")
  172.    write(tok_dot_h)
  173.    write(tok_dot_h, "/* operators */")
  174.    write(tok_dot_h)
  175.  
  176. # read operator file
  177.  
  178.    tok_chars := &lcase ++ &ucase ++ '_'
  179.  
  180.    op_linenum := 0
  181.    unary_set := set()
  182.    ops := table()
  183.    op_lst := []
  184.    
  185.    while s := read(opfile) do {
  186.       op_linenum +:= 1
  187.       s ? {
  188.          tab(many(white_sp))
  189.          if pos(0) | = "#" then
  190.             next
  191.          op := tab(upto(white_sp)) | err(opfnm, op_linenum,
  192.             "unexpected end of line")
  193.          tab(many(white_sp))
  194.          if ="(:=" then {
  195.             tab(many(white_sp))
  196.             if not ="AUG)" then
  197.                err(opfnm, op_linenum, "invalid augmented indication")
  198.             tab(many(white_sp))
  199.             aug := 1
  200.             }
  201.          else
  202.             aug := &null
  203.          tok := tab(many(tok_chars)) | err(opfnm, op_linenum, "invalid token")
  204.          tab(many(white_sp))
  205.          unary := tab(any('_us')) | err(opfnm,op_linenum,"invalid unary flag")
  206.          tab(many(white_sp))
  207.          binary := tab(any('_bs')) | err(opfnm,op_linenum,"invalid binary flag")
  208.          if unary == "_" & binary == "_" then
  209.             err(opfnm, op_linenum, "either unary or binary flag must be set")
  210.          if unary ~== "_" then {
  211.             if *op ~= 1 then
  212.                err(opfnm, op_linenum,
  213.                   "unary operators must be single characters: " || op);
  214.             insert(unary_set, op)
  215.             }
  216.          if \aug & binary == "_" then
  217.             err(opfnm, op_linenum,
  218.               "binary flag must be set for augmented assignment")
  219.  
  220.          ops[op] := op_sym(op, aug, tok, unary, binary)
  221.          }
  222.       }
  223.  
  224.    ops := sort(ops, 3)
  225.    while get(ops) & sym := get(ops) do
  226.      op_out(sym.op, sym.aug, sym.tokval, sym.unary, sym.binary)
  227.  
  228. # Skip more garbage
  229.  
  230.    garbage()
  231.  
  232. repeat {
  233.    wrt_op(token, tokval, bflag || eflag, 0, 1)
  234.    line := read(tokfile) | stop("premature end-of-file")
  235.    line ? tokpat() | break
  236.    }
  237.  
  238. # Skip more garbage
  239.  
  240.    garbage()
  241.  
  242. repeat {
  243.    wrt_op(token, tokval, bflag || eflag, 0, &null)
  244.    line := read(tokfile) | stop("premature end-of-file")
  245.    line ? tokpat() | break
  246.    }
  247.    write(toktab,
  248.       "   {{NULL,          0,     0},        0,              NULL, NULL}")
  249.    write(toktab, "   };")
  250.  
  251.    write(toktab)
  252.    if /asgn_loc then
  253.       stop(opfnm, " does not contain a definition for ':='")
  254.    if /semicol_loc then
  255.       stop(tokfnm, " does not contain a definition for ';'")
  256.    if /plus_loc then
  257.       stop(tokfnm, " does not contain a definition for '+'")
  258.    if /minus_loc then
  259.       stop(tokfnm, " does not contain a definition for '-'")
  260.    write(toktab, "int asgn_loc = ", asgn_loc, ";")
  261.    write(toktab, "int semicol_loc = ", semicol_loc, ";")
  262.    write(toktab, "int plus_loc = ", plus_loc, ";")
  263.    write(toktab, "int minus_loc = ", minus_loc, ";")
  264.  
  265.    op_trie := build_trie(op_lst)
  266.  
  267.    write(toktab);
  268.    wrt(toktab, 0, "/*")
  269.    wrt(toktab, 0, " * getopr - find the longest legal operator and return the")
  270.    wrt(toktab, 0, " *  index to its entry in the operator table.")
  271.    wrt(toktab, 0, " */\n")
  272.    wrt(toktab, 0, "int getopr(ac, cc)")
  273.    wrt(toktab, 0, "int ac;")
  274.    wrt(toktab, 0, "int *cc;")
  275.    wrt(toktab, 1, "{")
  276.    wrt(toktab, 1, "register char c;\n")
  277.    wrt(toktab, 1, "*cc = ' ';")
  278.    bld_slct(op_trie, "", "ac", toktab, 1)
  279.    wrt(toktab, 1, "tfatal(\"invalid character\", (char *)NULL);")
  280.    wrt(toktab, 1, "return -1;")
  281.    wrt(toktab, 1, "}")
  282. end
  283.  
  284. procedure makeline(token,tokval,flag,count)    # build an output line for token table.
  285.    local line
  286.    line := left("   \"" || token || "\",",22) || left(tokval ||  ",",15)
  287.    flag := flagtable[flag] || ","
  288.    if count ~=== "" then flag := left(flag,19)
  289.    line ||:= flag
  290.    if count ~=== "" then line ||:= "/* " || right(count,3) || " */"
  291.    return line
  292. end
  293.  
  294. # makeres - build an output line for reserved word index.
  295. #
  296. procedure makeres(lets, strt_repr)
  297.    local let, letters, line
  298.    static repr
  299.  
  300.    repr := \strt_repr
  301.  
  302.    line := "   "
  303.    letters := lets
  304.    every let := !lets do
  305.       if let ~== "." & \restable[let] then {
  306.          line ||:= "&toktab[" || right(restable[let],2) || "], "
  307.          }
  308.       else line ||:= "NULL,        "
  309.    line := left(line,55) || "/* " 
  310.    if integer(repr) then
  311.       line ||:= hex(repr) || "-" || hex((repr +:= *lets) - 1) || " "
  312.    return line || letters || " */"
  313. end
  314.  
  315. procedure garbage()
  316.    local line
  317.    while line := read(tokfile) | stop("premature end-of-file") do
  318.       if line ? tokpat() then return
  319. end
  320.  
  321. procedure hex(n)
  322.    local s
  323.    static hexdig
  324.  
  325.    initial hexdig := "0123456789ABCDEF"
  326.  
  327.    s := ""
  328.    while n > 0 do {
  329.       s := hexdig[n % 16 + 1] || s
  330.       n := n / 16
  331.       }
  332.    return s
  333. end
  334.  
  335. procedure op_out(op, aug, tokval, unary, binary)
  336.    local flag, arity
  337.  
  338.    if unary_str(op) then
  339.       flag := "b"
  340.    else
  341.       flag := ""
  342.    if unary == "u" then
  343.       arity := "Unary"
  344.    if binary == "b" then
  345.       if /arity then
  346.          arity := "Binary"
  347.       else
  348.          arity ||:= " | Binary"
  349.    /arity := "0"
  350.    wrt_op(op, tokval, flag, arity, 1)
  351.    if \aug then
  352.       wrt_op(op || ":=", "AUG" || tokval, "", "0", 1)
  353. end
  354.  
  355. procedure wrt_op(op, tokval, flag, arity, define)
  356.    static cnt
  357.  
  358.    initial cnt := 0;
  359.  
  360.    flag := flagtable[flag]
  361.    writes(toktab, "   {{\"", left(esc(op) || "\",", 9))
  362.    writes(toktab, left(tokval || ",", 12))
  363.    writes(toktab, left(flag || "},", 11))
  364.    writes(toktab, left(arity|| ",", 16))
  365.    write(toktab, "NULL, NULL}, /* ", cnt, " */")
  366.    if \define then
  367.       wrt_tok_def(tokval, op)
  368.    if op == ":=" then
  369.       asgn_loc := cnt
  370.    else if op == ";" then
  371.       semicol_loc := cnt
  372.    else if op == "+" then
  373.       plus_loc := cnt
  374.    else if op == "-" then
  375.       minus_loc := cnt
  376.    put(op_lst, association(op, cnt))
  377.    cnt +:= 1
  378. end
  379.  
  380. procedure wrt_tok_def(tokval, tok)
  381.    if \tok then
  382.       write(tok_dot_h, "%token\t", left(tokval, 12), "/* ", left(tok, 9),
  383.          " */")
  384.    else
  385.       write(tok_dot_h, "%token\t", tokval);
  386. end
  387.  
  388. procedure unary_str(op)
  389.    if op == "" then
  390.       return
  391.    if member(unary_set, op[1]) then
  392.       return unary_str(op[2:0])
  393. end
  394.  
  395. procedure err(file, line, msg)
  396.    stop(&errout, "file: ", file, ", line: ", line, " - ", msg)
  397. end
  398.  
  399. procedure build_trie(ops)
  400.    local by_1st_c, dflt, asc, c, c_ops
  401.  
  402.    by_1st_c := table()
  403.    every asc := !ops do {
  404.       #
  405.       # See if there are more characters in this operator.
  406.       #
  407.       if c := asc.op[1] then {
  408.           /by_1st_c[c] := []
  409.           put(by_1st_c[c], association(asc.op[2:0], asc.n))
  410.           }
  411.       else 
  412.           dflt := asc.n
  413.       }
  414.    by_1st_c := sort(by_1st_c)
  415.    every c_ops := !by_1st_c do
  416.       c_ops[2] := build_trie(c_ops[2])
  417.    return trie(by_1st_c, dflt)
  418. end
  419.  
  420.  
  421. # bld_slct - output selection code which will recongize operators
  422. #   represented by the given trie. Code has already been generated
  423. #   to recognize the string in prefix.
  424. procedure bld_slct(op_trie, prefix, char_src, f, indent)
  425.    local fall_through, by_1st_c, dflt, char, trie_1, a, ft
  426.  
  427.    by_1st_c := op_trie.by_1st_c
  428.    dflt := op_trie.dflt
  429.  
  430.    case *by_1st_c of {
  431.       0:
  432.          #
  433.          # There are no more characters to check. When execution gets
  434.          #  here in the generated code we have found a longest possible
  435.          #  operator: the one contained in prefix.
  436.          #
  437.          wrt(f, indent, "return " , dflt, ";   /* ", prefix, " */")
  438.       1: {
  439.          #
  440.          # If there is only one valid character to check for, generate an
  441.          #  if statement rather than a switch statement. If the character
  442.          #  is not next in the input, either we are already at the end of
  443.          #  a valid operator (in which case, the generated code must
  444.          #  must save the one-character look ahead) or the generated
  445.          #  code will fall through to an error message at the end of the
  446.          #  function.
  447.          #
  448.          char := by_1st_c[1][1]
  449.          trie_1 := by_1st_c[1][2]
  450.          wrt(f, indent, "if ((c = ", char_src, ") == '", esc(char), "') {")
  451.          fall_through := bld_slct(trie_1, prefix || char, "NextChar", f,
  452.             indent + 1)
  453.          wrt(f, indent + 1, "}")
  454.          if \dflt then {
  455.             wrt(f, indent, "else {")
  456.             wrt(f, indent + 1, "*cc = c;")
  457.             wrt(f, indent + 1, "return " , dflt, ";   /* ", prefix, " */")
  458.             wrt(f, indent + 1, "}")
  459.             }
  460.          else
  461.             fall_through := 1
  462.          }
  463.       default: {
  464.          #
  465.          # There are several possible next characters. Produce a switch
  466.          #  statement to check for them.
  467.          #
  468.          wrt(f, indent, "switch (c = ", char_src, ") {")
  469.          every a := !by_1st_c do {
  470.             char := a[1]
  471.             trie_1 := a[2]
  472.             wrt(f, indent + 1, "case '", esc(char), "':")
  473.             ft := bld_slct(trie_1, prefix || char, "NextChar", f, indent + 2)
  474.             if \ft then {
  475.                wrt(f, indent + 2, "break;")
  476.                fall_through := 1
  477.                }
  478.            }
  479.          if \dflt then {
  480.             wrt(f, indent + 1, "default:")
  481.             wrt(f, indent + 2, "*cc = c;")
  482.             wrt(f, indent + 2, "return " , dflt, ";   /* ", prefix, " */")
  483.             }
  484.          else
  485.             fall_through := 1
  486.          wrt(f, indent + 1, "}")
  487.          }
  488.       }
  489.  
  490.    return fall_through
  491. end
  492.  
  493. procedure wrt(f, indent, slst[])
  494.    local s1, i, exp_indent
  495.  
  496.    exp_indent := indent * 3;
  497.    s1 := repl(" ", exp_indent)
  498.    while s1 ||:= get(slst) 
  499.    if (*s1 > 80) then {
  500.       #
  501.       # line too long, find first space before 80th column, and
  502.       #  break there. note, this will not work in general. it may
  503.       #  break a line within a string.
  504.       #
  505.       every i := 80 to 1 by -1 do
  506.          if s1[i] == " " then
  507.             if i <= exp_indent then {
  508.                #
  509.                # we have indented too far
  510.                #
  511.                wrt(f, indent - 1, s1[exp_indent+1:0])
  512.                return
  513.                }
  514.             else {
  515.                write(f, s1[1:i])
  516.                wrt(f, indent, s1[i+1:0])
  517.                return
  518.                }
  519.       }
  520.    write(f, s1)
  521. end
  522.  
  523. procedure esc(c)
  524.    if c == "\\" then
  525.       return "\\\\"
  526.    else
  527.       return c
  528. end
  529.